SetDirectory["C:\\drorbn\\MathBlog\\2008-06"];
<< KnotTheory`
<< HeckeData.m

Perm /: Perm[p1___]**Perm[p2___] := Perm[p2][[{p1}]];
Perm[BR[n_, {}]] := Perm @@ Range[n];
Perm[BR[n_, {xs___, x_}]] := Module[{a=Abs[x]},
Perm[BR[n, {xs}]] /. {a-> a+1, a+1->a}
];

Phi2[b_BR, k_] := Module[
{n=First@b,perm,tt},
perm=Perm[b];
Sum[
tt=i;
While[tt>n-k, tt=perm[[tt]]];
-d*t[tt]*BR[n,Join[
-Range[n-k+1,i-1],
Last@b,
-Range[1,n-k-1],
Range[i-1,1,-1]
]],
{i,n-k+1,n}
]
];
Phi3[BR[n_, xings_List], k_] := Module[
{l=Length[xings],j, lft, rgt,jj,perm,tt},
Sum[
j=Abs[xings[[i]]];
lft=Join[
-Range[n-k+1,n],
Take[xings,i-1],
Range[n,2+j,-1]
];
rgt=Join[
Range[j-1,1,-1],
Drop[xings,i] /. {jj_Integer :> jj+Sign[jj]},
-Range[2,n-k]
];
perm=Perm[BR[n+1,Join[lft,{j,j+1,j}, rgt]]];
tt=Perm[BR[n+1,rgt]][[If[xings[[i]]>0,j+2, j+1]]];
While[tt>n-k, tt=perm[[tt]]];
Expand[t[tt]*(
BR[n+1,Join[lft,{j+1}, rgt]]-BR[n+1,Join[lft,{j}, rgt]]
)],
{i,l}
]
];

Flip[x_,j_] := ReplacePart[x, {j->x[[j+1]], j+1->x[[j]]}];
HB /: hb_HB * BR[_,{}] := hb;
HB /: hb_HB * BR[_,{j_}] /; j>0 := If[hb[[j]]<hb[[j+1]],
Flip[hb, j],
z*hb+Flip[hb,j]
];
HB /: hb_HB*BR[_, {j_}] /; j<0 := If[hb[[-j]] < hb[[1-j]],
Flip[hb, -j]- z*hb,
Flip[hb, -j]
];
HB /: hb_HB*BR[_, {j_, js__}] := Expand[Expand[hb*BR[0, {j}]]*BR[0, {js}]];
Proj[n_, x_] := Expand[HB@@Range[n]*x];
Proj[BR[n_, l_]] := Proj[n, BR[n,l]];

cl[0, x_] := x;
cl[k_, x_Plus] := cl[k,#]& /@ x;
cl[k_, hb_HB*x_.] := Module[
{n=Length[hb],p},
Expand[
cl[k-1, Expand[x*If[Last[hb]==n,
d*Drop[hb, -1],
1/v * DeleteCases[hb, n]*BR[0,Range[n-2,Position[hb, n][[1,1]],-1]]
]]]
]
];

Y1[BR[n_, xings_]] := Expand[(
cl[n, Proj[n+1, Phi3[BR[n,xings], n-1]]] + cl[n-1, Proj[n, Phi2[BR[n,xings], n-1]]]
) /. d -> (1/v-v)/z];

Double[BR[w_,br_List]] :=BR[2 w,Flatten[{
br/.{j_Integer:>{2 j+{0,-1,1,0}}},
Table[-Sign[Total[Sign@br]],{2*Abs[Total[Sign@br]]}]
}]];

Y2[B_BR] := Module[
{DB=Double[B], n=First@B},
Expand[(
cl[2n-1, Proj[2n+1, Phi3[DB, 2n-2]]] + cl[2n-2, Proj[2n, Phi2[DB, 2n-2]]]
) /. d -> (1/v-v)/z]
];

IndexOfPermutation[0,{}]=0;
IndexOfPermutation[1, {1}]=0;
IndexOfPermutation[n_, l_] := (n-1)!(n-Position[l, n][[1,1]])+IndexOfPermutation[n-1, Drop[l, -1] /. n -> Last[l]];
PermutationByIndex[0, 0] = {};
PermutationByIndex[1, 0] = {1};
PermutationByIndex[n_, k_] := Block[
{
tau=PermutationByIndex[n-1, k~Mod~((n-1)!)], p=n-k~Quotient~((n-1)!)
},
If[p==n,
Append[tau,n],
Append[tau /. tau[[p]] -> n, tau[[p]]]
]
];

HeckeMatrix[n_, j_] := HeckeMatrix[n, j] = Module[
{out,i},
SparseArray[Flatten[Table[
out=HB@@PermutationByIndex[n, i]*BR[0,{j}];
({i, IndexOfPermutation[n, List@@#]}+1 -> Coefficient[out, #])& /@ Cases[{out}, _HB, Infinity],
{i,0, n!-1}
]]]
];

HM[n_, j_] := HM[n,j] = SMP[
Map[Coefficient[#, z,0]&, HeckeMatrix[n,j], {2}],
Map[Coefficient[#, z,1]&, HeckeMatrix[n,j], {2}]
];

SMP /: x_SMP ** y_SMP := Module[
{degx=Length[x]-1, degy=Length[y]-1, i,k},
SMP@@Table[
Sum[
x[[i+1]].y[[k-i+1]],
{i,Max[0,k-degy],Min[degx, k]}
],
{k, 0, degx+degy}
]
];

ClosureMatrix[n_] := ClosureMatrix[n] = Module[
{out,i},
SparseArray[Flatten[Table[
out=Expand[cl[1, HB@@PermutationByIndex[n, i]] /. d-> (1/v-v)/z];
({i, IndexOfPermutation[n-1, List@@#]}+1 -> Coefficient[out, #])& /@ Cases[{out}, _HB, Infinity],
{i,0, n!-1}
]]]
];
ClosureMatrix[n_,1] := ClosureMatrix[n];
ClosureMatrix[n_, k_] /; k>1 := ClosureMatrix[n, k] = Map[Expand, ClosureMatrix[n].ClosureMatrix[n-1, k-1], {2}];

Homf[BR[n_, l_], k_] := Module[
{debug=True, tu, HStep, CStep, hm, out},
If[debug, tu=TimeUsed[]; Print["Homf at ", BR[n,l], ", ",k]];
HStep[h_, j_] := h**HM[n,j];
CStep[h_, j_] := Map[Expand, Dot[h, ClosureMatrix[j]], {1}];
hm = Fold[HStep, SMP[SparseArray[{{1} -> 1}, {n!}]], l];
If[debug, Print["Computed hm, time is ", TimeUsed[]-tu]];
out=Normal[Fold[CStep, z^Range[0, Length[hm]-1].(List@@hm), Range[n, n-k+1, -1]]];
If[debug, Print["Computed out, time is ", TimeUsed[]-tu]];
out
];
Homf[b_BR] := Homf[b, First@b-1];

FastY1[BR[n_, xings_]] := Expand[Plus[
Phi3[BR[n,xings], n-1] /. b_BR :> Homf[b, n],
Phi2[BR[n,xings], n-1] /. b_BR :> Homf[b, n-1]
] /. d -> (1/v-v)/z];

FastY2[B_BR] := Module[
{DB=Double[B], n=First@B},
Expand[Plus[
Phi3[DB, 2n-2] /. b_BR :> Homf[b, 2n-1],
Phi2[DB, 2n-2] /. b_BR :> Homf[b, 2n-2]
] /. d -> (1/v-v)/z]
];

{BraidPlot[B=BR[n=4, xings={1,3,2,1}]], k=2}

{BraidPlot[B=b1], Simplify[Y1[B]/HOMFLYPT[Mirror[B]][v,z]]}

{B=b1, Double[B]}

BraidPlot /@ {B=b1 , CollapseBraid[Double[B]]}

Y2[BR[Knot[4,1]]]

(Y2 /@ {BR[2,{1,1,1}], BR[2,{-1,-1,-1}]}) /. v->1

Phi3[B,2] /. b_BR :> BraidPlot[b]

Phi2[B,2] /. b_BR :> BraidPlot[b]

b1=BR[Knot[8,17]]

b2=BR[ArcPresentation[Knot[8,17]]]

Jones[#][q]& /@ {b1, b2}

Proj[b2] // Short

t1=Expand[cl[2, Expand[Proj[b1]]] /. {HB[1]->1, d->(1/v - v)/z}]

t2=Expand[cl[5, Expand[Proj[b2]]] /. {HB[1]->1, d->(1/v - v)/z}]

t0=HOMFLYPT[b1][v,z]

Simplify[t1/t0]

Simplify[t2/t0]